home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 8.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  63.8 KB  |  2,296 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #ifndef SEM
  10. #define SEM    1
  11. #endif
  12.  
  13. #include "hdr.h"
  14. #include "vars.h"
  15. #include "attr.h"
  16. #include "dclmapprots.h"
  17. #include "errmsgprots.h"
  18. #include "sspansprots.h"
  19. #include "nodesprots.h"
  20. #include "setprots.h"
  21. #include "miscprots.h"
  22. #include "smiscprots.h"
  23. #include "chapprots.h"
  24.  
  25. /*
  26.  CHECK HANDLING OF NEW_NAME in newmod    ds 30 jul
  27.  Sort out is_identifier usage        ds 26 nov 84
  28.  Bring C version of find_simple_name in closer correspondence to SETL
  29.  version.    ds 7 aug 84
  30.  
  31.  Note that set imported in collect_imported names is built on every call.
  32.  It is probably dead on return, but I am not copying it when I put in
  33.  in all_imported_names. May be able to do set_free(imported) before
  34.  return from collect_imported_names - look into this later.  ds 2 aug
  35. */
  36.  
  37. /*
  38.  * The following global variable is used for error reporting when
  39.  * several instances of an identifier end up hiding each other and
  40.  * the identifier is seen as undeclared or ambiguous.
  41.  */
  42. static Set all_imported_names; /*TBSL: initialize to (Set)0 */
  43.  
  44.  
  45. static Set collect_imported_names(char *);
  46. static void name_error(Node);
  47. static void find_simple_name(Node);
  48. static void array_or_call(Node);
  49. static int parameterless_callable(Symbol);
  50. static void index_or_slice(Node);
  51. static void find_selected_comp(Node);
  52. static void find_exp_name(Node, Symbol, char *);
  53. static void all_declarations(Node, Symbol, char *, Symbol);
  54. static int has_implicit_operator(Node, Symbol, char *);
  55. static void make_any_id_node(Node);
  56. static int is_appropriate_for_record(Symbol);
  57. static int is_appropriate_for_task(Symbol);
  58. static Symbol renamed(Node, Tuple, Symbol);
  59. static Symbol op_matches_spec(Symbol, Tuple, Symbol);
  60. static void check_modes(Tuple, Symbol);
  61. static void renamed_entry(Node, Tuple);
  62.  
  63. void find_old(Node id_node)                                    /*;find_old*/
  64. {
  65.     /*
  66.      * Establish unique name of identifier, or of syntactic category name.
  67.      * Yield error in the case of undefined identifier.
  68.      * In the case of long and short integers, indicate that they are
  69.      * unimplemented rather than 'undefined'.
  70.      */
  71.     Symbol    u_name;
  72.     char    *id;
  73.     char    *newn;
  74.     int        unsupported;
  75.  
  76.     if (cdebug2 > 3)
  77.         TO_ERRFILE("AT PROC :  find_old");
  78.  
  79.     check_old(id_node);
  80.     if (N_KIND(id_node) != as_simple_name) return; /* added 7 jul */
  81.     u_name = N_OVERLOADED(id_node) ? (Symbol) 0 : N_UNQ(id_node);
  82.     id = N_VAL(id_node);
  83.     if (u_name == symbol_undef) {
  84.         if (streq(id, "LONG_INTEGER") || streq(id, "SHORT_INTEGER")) {
  85.             unsupported = TRUE;
  86.             u_name = symbol_integer; /* new type to use */
  87.         }
  88.         else if (streq(id, "SHORT_FLOAT") || streq(id, "LONG_FLOAT")) {
  89.             unsupported = TRUE;
  90.             u_name = symbol_float; /* new type to use */
  91.         }
  92.         else {
  93.             unsupported = FALSE;
  94.         }
  95.  
  96.         if (!unsupported) {
  97.             /* The identifier is undefined, or not visible. This is an error.*/
  98.             name_error(id_node);
  99.         }
  100.         else {
  101.             /* The identifier names unsupported type. This is error, so
  102.              * issue error message and then change type to avoid further
  103.              * spurious error messages
  104.              */
  105. #ifdef ERRNUM
  106.             str_errmsgn(420, id, 10, id_node);
  107. #else
  108.             errmsg_str("% is not supported in current implementation",
  109.               id, "none", id_node);
  110. #endif
  111.             N_UNQ(id_node) = u_name;
  112.             return;
  113.         }
  114.         /* insert in current scope, and give it default type.*/
  115.         if (dcl_get(DECLARED(scope_name), id) == (Symbol)0
  116.           && set_size(all_imported_names) == 0) {
  117.             newn = id;
  118.             u_name = find_new(newn);
  119.             NATURE(u_name)    = na_obj; /* Could be more precise.*/
  120.             N_UNQ(id_node) = u_name;
  121.         }
  122.         TYPE_OF(u_name) = symbol_any;
  123.         ALIAS(u_name) = symbol_any;
  124.     }
  125. }
  126.  
  127. Symbol find_type(Node node) /*;find_type*/
  128. {
  129.     Symbol    type_mark;
  130.  
  131.     /* Resolve a name that must yield a type mark.*/
  132.     find_old(node);
  133.     type_mark = N_UNQ(node);
  134.     if (N_OVERLOADED(node) || type_mark == (Symbol)0
  135.       || !is_type(type_mark) && TYPE_OF(type_mark) != symbol_any) {
  136. #ifdef ERRNUM
  137.         errmsgn(421, 10, node);
  138. #else
  139.         errmsg("Invalid type mark ", "none", node);
  140. #endif
  141.         N_UNQ(node) = type_mark = symbol_any;
  142.     }
  143.     return type_mark;
  144. }
  145.  
  146. static void name_error(Node id_node)  /*;name_error*/
  147. {
  148.  
  149.     char    *id;
  150.     char    *names;
  151.  
  152.     if (cdebug2 > 3)
  153.         TO_ERRFILE("AT PROC :  name_error");
  154.     /*
  155.      * Name was not found in environment. This may be because it is undeclared,
  156.      * or because several imported instances of the name hide each other.
  157.      * The marker '?' is also returned when a type name is mentioned in
  158.      * the middle of its own elaboration.
  159.      */
  160.     id = N_VAL(id_node);
  161.     if (set_size(all_imported_names) == 0) {
  162.         if (dcl_get(DECLARED(scope_name), id) == (Symbol)0) {
  163. #ifdef ERRNUM
  164.             str_errmsgn(422, id, 207, id_node);
  165. #else
  166.             errmsg_str("identifier undeclared or not visible %", id, "3.1", id_node);
  167. #endif
  168.         }
  169.         else {
  170. #ifdef ERRNUM
  171.             str_errmsgn(423, id, 126, id_node);
  172. #else
  173.             errmsg_str("Invalid reference to %", id , "3.3", id_node);
  174. #endif
  175.         }
  176.     }
  177.     else {
  178. #ifdef TBSL
  179.         names = +/[ original_name(scope_of(x)) + '.' + original_name(x)
  180.             + ' ':    x in all_imported_names ];
  181. #endif
  182.         names = build_full_names(all_imported_names);
  183. #ifdef ERRNUM
  184.         str_errmsgn(424, names, 390, id_node);
  185. #else
  186.         errmsg_str("Ambiguous identifier. Could be one of: %",
  187.           names, "8.3, 8.4", id_node);
  188. #endif
  189.     }
  190. }
  191.  
  192. void check_old(Node n_node)  /*;check_old*/
  193. {
  194.     Node    node, attr, arg1, expn;
  195.     int    nk;
  196.  
  197.     if (cdebug2 > 3) {
  198.         TO_ERRFILE("AT PROC :  check_old");
  199.         printf("  kind %s\n", kind_str(N_KIND(n_node))); /*DEBUG*/
  200.     }
  201.     /*
  202.      * This procedure performs name resolution for several syntactic
  203.      * instances of names. These include identifiers, selected components,
  204.      * array indexing and slicing, function calls and attribute expressions.
  205.      * If -name- is an identifier and is undeclared, this proc yields
  206.      * the special marker '?' which is used by error routines.
  207.      * If -name- is overloaded, the procedure returns the set of overloaded
  208.      * names which correspond to -name-. This set is constructed by
  209.      * scanning first the open scopes, and then examining visible packages.
  210.      * To facilitate the collection of overloaded names, the procedure
  211.      * chain_overload, which is called when a procedure specification, or
  212.      * and enumeration type are processed, collects successive overloads of the
  213.      * same id together, using the -overloads- field of the symbol table.
  214.      */
  215.  
  216.     switch (nk = N_KIND(n_node)) {
  217.       case    as_simple_name:
  218.       case    as_character_literal:
  219.       case    as_package_stub:
  220.       case    as_task_stub:
  221.                 find_simple_name(n_node);
  222.                 break;
  223.       case    as_call_unresolved:
  224.                 array_or_call(n_node);
  225.                 break;
  226.       case    as_selector:
  227.                 find_selected_comp(n_node);
  228.                 break;
  229.       case    as_string:
  230.                 N_KIND(n_node) = as_simple_name; /* Treat as simple*/
  231.                 find_simple_name(n_node);            /* name.*/
  232.                 break;
  233.       case    as_name:
  234.       case    as_range_expression:
  235.                 node = N_AST1(n_node);
  236.                 find_old(node);
  237.                 copy_attributes(node, n_node);
  238.                 break;
  239.       case    as_attribute:
  240.                 attr = N_AST1(n_node);
  241.                 arg1 = N_AST2(n_node);
  242.                 find_old(arg1);
  243.                 break;
  244.       case    as_all:
  245.                 expn = N_AST1(n_node);
  246.                 find_old(expn);
  247.                 break;
  248.     }
  249. }
  250.  
  251. static void find_simple_name(Node n_node)        /*;find_simple_name*/
  252. {
  253.     char    *id;
  254.     Symbol    sc;
  255.     int        sc_num;
  256.     Symbol    u_name, o, n, u_n;
  257.     Symbol    found, foreign;
  258.     Set        names, names_add, found_set;
  259.     Set imported;
  260.     int        i, exists, found_is_set;
  261.     Forset    fs1, fs2;
  262.     Symbol    sym;
  263.  
  264.     id = N_VAL(n_node);
  265.  
  266.     if (cdebug2 > 0) {
  267.         TO_ERRFILE(" looking for id. " );
  268.         printf("  kind %s %s\n", kind_str(N_KIND(n_node)), id); /*DEBUG*/
  269.     }
  270.  
  271.     exists = FALSE;
  272.     for (sc_num = 1; sc_num <= tup_size(open_scopes); sc_num++) {
  273.         sc = (Symbol)open_scopes[sc_num];
  274.         u_name = dcl_get(DECLARED(sc), id);
  275.         if     (u_name != (Symbol)0) {
  276.             exists = TRUE;
  277.             break;
  278.         }
  279.     }
  280.     if (exists) {
  281.         if (!can_overload(u_name)) {
  282.             found_is_set = FALSE;
  283.             found = u_name;
  284.             TO_XREF(u_name);
  285.         }
  286.         else {
  287.             names = set_copy(OVERLOADS(u_name));
  288.  
  289.             /* Scan open scopes for further overloadings.*/
  290.             for (i = sc_num+1; i <= tup_size(open_scopes); i++) {
  291.                 u_n = dcl_get(DECLARED(((Symbol)open_scopes[i])), id);
  292.                 if (u_n == (Symbol)0) continue;
  293.                 else if (!can_overload(u_n)) {
  294.                     found_is_set = TRUE;
  295.                     found_set = names;
  296.                 }
  297.                 else {
  298.                     names_add = set_new(0);
  299.                     FORSET(o=(Symbol), OVERLOADS(u_n), fs1);
  300.                         exists = FALSE;
  301.                         FORSET(n=(Symbol), names, fs2);
  302.                             if (same_type(TYPE_OF(n), TYPE_OF(o)) &&
  303.                               same_signature(n, o)) {
  304.                                 exists = TRUE;
  305.                                 break;
  306.                             }
  307.                         ENDFORSET(fs2);
  308.                         if (!exists) names_add = set_with(names_add, (char *)o);
  309.                     ENDFORSET(fs1);
  310.                     FORSET(o=(Symbol), names_add, fs1);
  311.                         names = set_with(names, (char *)o);
  312.                     ENDFORSET(fs1);
  313.                     set_free(names_add);
  314.                 }
  315.             }
  316.             imported = collect_imported_names(id);
  317.             /* Keep only the imported names which are not hidden
  318.              * by visible names with the same signature.
  319.              */
  320.             if (set_size(imported)>1 ||
  321.               (set_size(imported) == 1 &&
  322.               can_overload((Symbol)set_arb(imported)))) {
  323.                 names_add = set_new(0);
  324.                 FORSET(foreign=(Symbol), imported, fs1);
  325.                     exists = FALSE;
  326.                     FORSET(n=(Symbol), names, fs2);
  327.                         if (same_type(TYPE_OF(n), TYPE_OF(foreign)) &&
  328.                             same_signature(n, foreign)) {
  329.                             exists = TRUE;
  330.                             break;
  331.                         }
  332.                         ENDFORSET(fs2);
  333.                     if (!exists)
  334.                         names_add = set_with(names_add, (char *)foreign);
  335.                 ENDFORSET(fs1);
  336.                 FORSET(n=(Symbol), names_add, fs1);
  337.                     names = set_with(names, (char *) n);
  338.                 ENDFORSET(fs1);
  339.                 set_free(names_add);
  340.             }
  341.             found_is_set = TRUE;
  342.             found_set = names;
  343.         }
  344.     }
  345.     else if ((imported = collect_imported_names(id) , set_size(imported)) != 0){
  346.         if (set_size(imported)>1 || can_overload((Symbol)set_arb(imported))) {
  347.             found_is_set = TRUE;
  348.             found_set = imported;
  349.         }
  350.         else {
  351.             found_is_set = FALSE;
  352.             found = (Symbol) set_arb(imported);
  353.         }
  354.     }
  355.     /* the syntactic error recovery routine sends a '' when it can
  356.      * recover by token insertion. return it as is, to avoid
  357.      * subsequent spurious messages.
  358.      */
  359.     /* #if DEAD */
  360.     /* DEAD (as best we can tell  7 jul */
  361.     else if (streq(id, "any_id")) {
  362.         found_is_set = FALSE;
  363.         found = symbol_any_id;
  364.     }
  365. #ifdef DEAD
  366.     else if (id == (Symbol)0) {
  367.         found_is_set = FALSE;
  368.         found = id;
  369.     }
  370. #endif
  371.     else {
  372.         found_is_set = FALSE;
  373.         found = symbol_undef; /* need to add symbol_undef '?' */
  374.     }
  375.     if (found_is_set) {
  376.         N_OVERLOADED(n_node) = TRUE;
  377.         N_NAMES(n_node) = found_set;
  378.     }
  379.     else {
  380.         N_OVERLOADED(n_node) = FALSE;
  381.         N_UNQ(n_node) = found;
  382.     }
  383.     if (cdebug2 == 0) return; /* rest is debugging trace only*/
  384.  
  385.     if (cdebug2 > 0) TO_ERRFILE ("found name(s): " );
  386. /* always print found names */
  387.     if (found_is_set) {
  388.         FORSET(sym=(Symbol), found_set, fs1)
  389. #ifdef IBM_PC
  390.             printf("%p", sym);
  391. #else
  392.         printf("%ld", sym);
  393. #endif
  394.         if (sym!=(Symbol)0) printf("%s", ORIG_NAME(sym));
  395.         printf("\n");
  396.         ENDFORSET(fs1);
  397.     }
  398.     else {
  399. #ifdef IBM_PC
  400.         printf("found name %p  ", found);
  401. #else
  402.         printf("found name %ld  ", found);
  403. #endif
  404.         /* symbol_undef should not need special handling  ds 17 jul
  405.         if (found == symbol_undef) printf("?\n");
  406.         else
  407.  */
  408.         if (found!=(Symbol)0) printf("%s\n", ORIG_NAME(found));
  409.     }
  410. }
  411.  
  412. static Set collect_imported_names(char *id)        /*;collect_imported_names*/
  413. {
  414.     Set imported;
  415.     Symbol    used;
  416.     Symbol    s;
  417.     Symbol    foreign;
  418.     Fortup    ft1;
  419.     Forset    fs1;
  420.  
  421.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  collect_imported_names");
  422.     /*
  423.      * This procedure collects the set of all imported names corresponding
  424.      * to identifier -name-, which appear in currently visible package.
  425.      * An imported identifier is visible if :
  426.      * a) It is not an overloadable identifier, and it appears in only
  427.      * one used package.
  428.      * b) Or, all of its appearances in used modules are overloadable.
  429.      */
  430.     imported = set_new(0);
  431.     /*
  432.      * (forall used in used_mods | (f:= visible(used)) /= om
  433.      *                 and (foreign := f(id)) /= om )
  434.      */
  435.     FORTUP(used=(Symbol), used_mods, ft1);
  436.         if (DECLARED(used) == (Declaredmap)0) continue;
  437.         foreign = dcl_get_vis(DECLARED(used), id);
  438.         if (foreign !=(Symbol)0) {
  439.             if (can_overload(foreign)){
  440.                 FORSET(s=(Symbol), OVERLOADS(foreign), fs1);
  441.                     imported = set_with(imported, (char *)s);
  442.                 ENDFORSET(fs1);
  443.             }
  444.             else {
  445.                 if (set_size(imported) != 0) {
  446.                     /* mutual hiding. Save all for error message.*/
  447.                     /* imported dead - no need to copy    ds 2 aug */
  448.                     all_imported_names = imported;
  449.                     all_imported_names = set_with(all_imported_names,
  450.                       (char *) foreign);
  451.                     return set_new(0);
  452.                 }
  453.                 else {
  454.                     imported = set_new1((char *) foreign);
  455.                 }
  456.             }
  457.         }
  458.     ENDFORTUP(ft1);
  459.  
  460.     if (cdebug2 > 1) TO_ERRFILE("Imported names:");
  461.  
  462.     /* Save imported names in global variable, for possible error message.*/
  463.     all_imported_names = imported;
  464.     return imported;
  465. #ifdef TBSL
  466.     -- this code seems to be dead  review this with Ed  ds    12-dec-84
  467.         exists = FALSE;
  468.     FORSET(fgn=(Symbol), imported, fs1);
  469.         if (!can_overload(fgn)) {
  470.             exists = TRUE;
  471.             break;
  472.         }
  473.     ENDFORSET(fs1);
  474.     if (exists) {
  475.         /* If it is the only name found, return it.*/
  476.         if (set_size(imported) == 1) {
  477.             /*set_free(imported);*/
  478.             return set_new1(fgn);
  479.         }
  480.         else {
  481.             /*set_free(imported);*/
  482.             return set_new(0);
  483.             /* various visible names hide each other.*/
  484.         }
  485.     }
  486.     else {
  487.         /* All occurrences are overloadable. Return only those which do*/
  488.         if (cdebug2 > 1) {
  489.             TO_ERRFILE("Names:");
  490.             return imported;
  491.         }
  492.     }
  493. #endif
  494. }
  495.  
  496. static void array_or_call(Node n_node)    /*;array_or_call*/
  497. {
  498.     /*
  499.      * This procedure resolves the construct
  500.      *    name aggregate
  501.      * The meaning of this construct is one of the following :
  502.      * a) Indexed expression or slice.
  503.      * b) function call.
  504.      * d) Conversion.
  505.      */
  506.  
  507.     Node    prefix_node, agg_node, call_node, index_node, p_node;
  508.     Tuple    arg_list;
  509.     Set        f_names, npfs;
  510.     Symbol    f, t;
  511.     Forset    fs1;
  512.  
  513.     if (cdebug2 > 3)
  514.         TO_ERRFILE("AT PROC :  array_or_call");
  515.  
  516.     prefix_node = N_AST1(n_node);
  517.     agg_node = N_AST2(n_node);
  518.     arg_list = N_LIST(agg_node);
  519.  
  520.     /* Find unique name of object (procedure, array, etc).*/
  521.     find_old(prefix_node);
  522.     /*  Need different error flag. */
  523.     if (N_UNQ(prefix_node) == (Symbol)symbol_undef)
  524.         /* error message emitted already by find_old.*/
  525.         return;
  526.  
  527.     if (N_OVERLOADED(prefix_node)) {
  528.         f_names = N_NAMES(prefix_node);
  529.         /* function call.*/
  530.         N_KIND(n_node) = as_call;
  531.         /* The  nature of at least one  of the  overloaded instances     must be
  532.          * callable.     This  is  checked  by the type resolution  routines. An
  533.          * unpleasant syntactic ambiguity appears if parameterless  functions
  534.          * that  return an  array type appear  in obj_name. In this    case the
  535.          * expression must  be reformatted  as an indexing on the result of a
  536.          * function    call. If  both parameterless  and  parametered functions
  537.          * are present, then the  tree itself is ambiguous, and both parsings
  538.          * must be carried, to be resolved by the type resolution routines.
  539.          */
  540.         npfs = set_new(0);
  541.         FORSET(f=(Symbol), f_names, fs1);
  542.             t = TYPE_OF(f);
  543.             if (parameterless_callable(f) && (is_array(t)
  544.               || is_access(t) && is_array((Symbol)designated_type(t))))
  545.                 npfs = set_with(npfs, (char *)f);
  546.         ENDFORSET(fs1);
  547.         if (set_size(npfs) != 0) {
  548.             index_or_slice(n_node);
  549.  
  550.             if (N_KIND(n_node) == as_slice) {
  551.                 /* no ambiguity: it must be a slice.*/
  552.                 ; }
  553.             else {
  554.                 /* Construct subtrees with both parsings.*/
  555.                 call_node  = copy_node(n_node);
  556.                 N_KIND(call_node) = as_call;
  557.                 index_node = copy_tree(n_node);
  558.                 p_node = N_AST1(index_node);
  559.                 N_NAMES(p_node) = npfs;
  560.                 N_OVERLOADED(p_node)= TRUE;
  561.  
  562.                 N_KIND(n_node) = as_call_or_index;
  563.                 N_AST1(n_node)  = call_node;
  564.                 N_AST2(n_node)  = index_node;
  565.             }
  566.         }
  567.     }
  568.     else if (is_type(N_UNQ(prefix_node))) {
  569.         /* Case of a conversion.*/
  570.         N_KIND(n_node) = as_convert;
  571.         if (tup_size(arg_list) == 1) {
  572.             /* Conversion of a single expression. $$$ What about a choice?*/
  573.             N_AST1(n_node) = prefix_node;
  574.             N_AST2(n_node) = (Node)arg_list[1];
  575.         }
  576.         else {
  577.             /* Conversion of an aggregate: label it as such.*/
  578.             N_KIND(agg_node) = as_aggregate;
  579.         }
  580.     }
  581.     else{
  582.         index_or_slice(n_node);
  583.     }
  584. }
  585.  
  586. static int parameterless_callable(Symbol f)   /*;parameterless_callable*/
  587. {
  588.     /*
  589.      * Assert  that f is  a parameterless function, or  that default values
  590.      * exist for all its parameters and it can be called without arguments.
  591.      */
  592.  
  593.     Symbol    formal;
  594.     Fortup    ft1;
  595.  
  596.     if (NATURE(f) !=na_function && NATURE(f)!=na_function_spec)
  597.         return FALSE;
  598.     FORTUP(formal=(Symbol), SIGNATURE(f), ft1);
  599.         if ((Node)default_expr(formal) == OPT_NODE ) return FALSE;
  600.     ENDFORTUP(ft1);
  601.     return TRUE;
  602. }
  603.  
  604. static void index_or_slice(Node n_node)     /*;index_or_slice*/
  605. {
  606.     /*
  607.      * A slice is not always recognizable syntactically from an
  608.      * indexing expression. v(arg) is a slice in 3 cases:
  609.      * a) arg is a range : L..R
  610.      * b) arg is of the form V'RANGE
  611.      * c) arg is a type mark, possibly with a range constraint.
  612.      */
  613.     Node    prefix_node, index_node, constraint;
  614.     Tuple    index_list;
  615.     int        index_kind;
  616.     Node    index;
  617.  
  618.     prefix_node = N_AST1(n_node);
  619.     index_node = N_AST2(n_node);
  620.     index_list = N_LIST(index_node);
  621.     N_KIND(n_node) = as_index; /* most likely. */
  622.  
  623.     if (tup_size(index_list) == 1) {
  624.         index = (Node)index_list[1];
  625.         index_kind = N_KIND(index );
  626.         if (index_kind == as_subtype)
  627.             N_KIND(n_node) = as_slice;
  628.         else if (index_kind == as_range) {
  629.             /* Reformat it as subtype of unknown type.*/
  630.             constraint = copy_node(index);
  631.             N_KIND(index) = as_subtype;
  632.             N_AST1(index) = OPT_NODE;
  633.             N_AST2(index) = constraint;
  634.             N_KIND(n_node) = as_slice;
  635.         }
  636.         else if (index_kind == as_name) {
  637.             find_old(index);
  638.             if (is_type(N_UNQ(index)) || (N_KIND(index) == as_attribute
  639.               && ((int)attribute_kind(index) == ATTR_RANGE
  640.               ||  (int)attribute_kind(index) == ATTR_O_RANGE
  641.               ||  (int)attribute_kind(index) == ATTR_T_RANGE)))
  642.                 N_KIND(n_node) = as_slice;
  643.         }
  644.     }
  645. }
  646.  
  647. static void find_selected_comp(Node n_node) /*;find_selected_comp*/
  648. {
  649.     Node    prefix_node, s_node;
  650.     char    *selector;
  651.     Set        objset;
  652.     Symbol    prefix, prefix_type, u_n;
  653.     Forset    fs1;
  654.     int        prefix_nat;
  655.     Symbol    subp;
  656.     Span    save_span;
  657.  
  658.     if (cdebug2 > 3)
  659.         TO_ERRFILE("AT PROC :  find_selected_comp");
  660.  
  661.     prefix_node = N_AST1(n_node);
  662.     s_node      = N_AST2(n_node);
  663.     selector    = N_VAL(s_node);
  664.     save_span   = get_left_span(n_node);
  665.  
  666.     find_old(prefix_node);
  667.  
  668.     if (NATURE(scope_name) == na_void && streq(ORIG_NAME(scope_name), selector))
  669. #ifdef ERRNUM
  670.         str_errmsgn(425, selector, 50, s_node);
  671. #else
  672.         errmsg_str("premature usage of %", selector, "8.3(16)", s_node);
  673. #endif
  674.  
  675.     if (N_KIND(prefix_node) == as_simple_name && !N_OVERLOADED(prefix_node)){
  676.         prefix = N_UNQ(prefix_node);
  677.         prefix_type = TYPE_OF(prefix);
  678.         prefix_nat = NATURE(prefix);
  679.         if (prefix_nat == na_package_spec || prefix_nat == na_package)
  680.             find_exp_name(n_node, prefix, selector);
  681.         else if (is_appropriate_for_record(prefix_type))  {
  682.             /* Type checking will verify that the selector denotes a
  683.              * discriminant or component of the corresponding record or value.
  684.              */
  685.             ;
  686.         }
  687.         else if (is_appropriate_for_task(prefix_type)
  688.             /* if the selector is an entry name, return it as as selected
  689.              * component.  Context is an entry call or the prefix of the
  690.              * attribute COUNT.
  691.              */
  692.           && (is_access(prefix_type)
  693.           || (((u_n= dcl_get(DECLARED(prefix_type), selector))!= (Symbol)0)
  694.           && (NATURE(u_n)  == na_entry || NATURE(u_n) == na_entry_family)))) {
  695.             ;
  696.         }
  697.         /* other forms of selected components are expanded names. */
  698.  
  699.         else if (in_open_scopes(prefix) && prefix_nat != na_void) {
  700.             /* prefix denotes an enclosing loop, block, or task, i.e. an
  701.              * enclosing construct that is not a subprogram or accept statement.
  702.               */
  703.             find_exp_name(n_node, prefix, selector);
  704.         }
  705.  
  706.         else {             /* various error cases. */
  707.             if (prefix_type == symbol_any) {
  708.                 /* Object was undeclared, and error message emitted already.*/
  709.                 ;
  710.             }
  711.             else if (NATURE(prefix) == na_void) {
  712. #ifdef ERRNUM
  713.                 id_errmsgn(425, prefix, 50, n_node);
  714. #else
  715.                 errmsg_id("premature usage of %", prefix, "8.3(16)", n_node);
  716. #endif
  717.             }
  718.             else {
  719. #ifdef ERRNUM
  720.                 errmsgn(428, 429, n_node);
  721. #else
  722.                 errmsg("Invalid prefix in qualified name", "4.1.3", n_node);
  723. #endif
  724.             }
  725.             make_any_id_node(n_node);
  726.         }
  727.         return;
  728.     }
  729.     if (N_KIND(prefix_node) != as_simple_name) {
  730.         /* if the prefix is not a simple name (overloaded or not) it must be
  731.           * be an expression whose type is appropriate for a record or access
  732.           * type. Its full resolution requires type resolution as well. Nothing
  733.           * else is done here.
  734.           */
  735.         ;
  736.         return;
  737.     }
  738.     objset= N_NAMES(prefix_node);
  739.  
  740.     /* At this point the prefix is an overloaded name. It can be an enclosing
  741.       * subprogram or accept statement. It can also be a call to a parameterless
  742.       * function that yields a record value.
  743.       */
  744.     FORSET(subp=(Symbol), objset, fs1);
  745.         if (in_open_scopes(subp )) {
  746.             /* TBSL: more than one visible such name. */
  747.             find_exp_name(n_node, subp, selector);
  748.             return;
  749.         }
  750.     ENDFORSET(fs1);
  751.  
  752.     /* if no interpretation as an expanded name is possible, it must be a
  753.       * selected component of a record returned by a function call.
  754.       */
  755.     FORSET(subp=(Symbol), objset, fs1);
  756.         if (parameterless_callable(subp))
  757.             return;
  758.     ENDFORSET(fs1);
  759.     /* nothing found.*/
  760.     make_any_id_node(n_node);
  761. #ifdef ERRNUM
  762.     errmsgn(430, 429, n_node);
  763. #else
  764.     errmsg("Ambiguous name in selected component", "4.1.3", n_node);
  765. #endif
  766. }
  767.  
  768. static void find_exp_name(Node n_node, Symbol prefix, char *selector)
  769.   /*;find_exp_name*/
  770. {
  771.     /* resolve an expanded name whose prefix denotes a package or an enclosing
  772.      * construct.
  773.      */
  774.  
  775.     Symbol    entity;
  776.  
  777.     if (in_open_scopes(prefix))
  778.         entity = dcl_get(DECLARED(prefix), selector);
  779.     else                    /* prefix is package. */
  780.         entity = dcl_get_vis(DECLARED(prefix), selector);
  781.     if (entity !=(Symbol)0)
  782.         /* If the object is overloaded, collect its local occurences.*/
  783.         all_declarations(n_node, prefix, selector, entity);
  784.     else if (has_implicit_operator(n_node, prefix, selector)) {
  785.         /* It can still be an implicitly defined operator obtained by derivation
  786.          * of a predefined type within the given construct.
  787.          */
  788.         ;
  789.     }
  790.     else {
  791.         make_any_id_node(n_node);
  792. #ifdef ERRNUM
  793.         str_id_errmsgn(426, selector, prefix, 427, n_node);
  794. #else
  795.         errmsg_str_id("% not declared in %" , selector,
  796.           prefix, "4.1.3, 8.3", n_node);
  797. #endif
  798.     }
  799. }
  800.  
  801. static void all_declarations(Node n_node, Symbol prefix, char *selector,
  802.   Symbol entity) /*;all_declarations*/
  803. {
  804.     /* collect all declarations that overload an entity that is declared
  805.      * in a given construct. If the entity is not overloadable it is returned
  806.      * as is (a simple name). Otherwise the local overloading must also be
  807.      * collected. This is made complicated by the possible presence of implicit
  808.      * operators, which are created by the derivation of predefined types, but
  809.      * are nto inserted explicitly into the symbol table of the declarative
  810.      * part where they occur.
  811.      */
  812.  
  813.     int        forall, ii;
  814.     Symbol    predef_op, subp, f;
  815.     Forset    fs1;
  816.     Tuple    tup;
  817.     Set        nams;
  818.     Span    save_span;
  819.  
  820.     save_span = get_left_span(n_node);
  821.     N_KIND(n_node) = as_simple_name;    /* most likely case.*/
  822.     N_OVERLOADED(n_node) = FALSE;
  823.     if (can_overload(entity)) {
  824.         nams = set_copy(OVERLOADS(entity));
  825.         if( in_op_designators(selector) && prefix!=symbol_standard0 ){
  826.             /* Include implicitly defined operators, if they are not hidden by
  827.               * an explicit declaration in the scope. To determine whether it is
  828.               * hidden, compare it with the signature of the user-defined
  829.              *operator just as for the resolution of renamings.
  830.               */
  831.             predef_op = dcl_get(DECLARED(symbol_standard0), selector);
  832.             forall = TRUE;
  833.             FORSET(subp=(Symbol), nams, fs1);
  834.                 tup = tup_new(tup_size(SIGNATURE(subp)));
  835.                 for (ii = 1; ii <= tup_size(SIGNATURE(subp)); ii++) {
  836.                     f = (Symbol) ((SIGNATURE(subp))[ii]);
  837.                     tup[ii] = (char *)TYPE_OF(f);
  838.                 }
  839.                 if (!(op_matches_spec(predef_op, tup, TYPE_OF(subp))
  840.                    == (Symbol)0)) {
  841.                     forall = FALSE;
  842. #ifdef TUPFREE
  843.                     tup_free(tup);
  844. #endif
  845.                     break;
  846.                 }
  847. #ifdef TUPFREE
  848.                 tup_free(tup);
  849. #endif
  850.             ENDFORSET(fs1);
  851.             if (forall) {
  852.                 /* leave as qualified name, for resolution in
  853.                  * procedure result_types.
  854.                   */
  855.                 nams = set_with(nams, (char *)predef_op);
  856.                 N_KIND(n_node) = as_selector;
  857.             }
  858.         }
  859.         /* in any case, entity is overloaded.*/
  860.         N_OVERLOADED(n_node) = TRUE;
  861.         N_NAMES(n_node) = nams;
  862.     }
  863.     if (N_KIND(n_node) == as_simple_name) {
  864.         if (!N_OVERLOADED(n_node)) N_UNQ(n_node) = entity;
  865.         N_AST2(n_node) = (Node)0;
  866.         N_VAL(n_node) = selector;
  867.         set_span(n_node, save_span);
  868.         TO_XREF(entity);
  869.     }
  870. }
  871.  
  872. static int has_implicit_operator(Node n_node, Symbol scope, char *selector)
  873.   /*;has_implicit_operator*/
  874. {
  875.     Fordeclared fd1;
  876.     Symbol    root, typ;
  877.     char    *id;
  878.  
  879.     if (!in_op_designators(selector))
  880.         return FALSE;
  881.     FORDECLARED(id, typ, DECLARED(scope), fd1);
  882.         if (!is_type(typ)) continue;
  883.         root = root_type (typ);
  884.  
  885.         if ( !is_limited_type (typ)
  886.           && (streq(selector, "=") || streq(selector, "/="))) {
  887.             N_OVERLOADED(n_node) = TRUE;
  888.             N_NAMES(n_node) =
  889.               set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  890.             return TRUE;
  891.         }
  892.         if (((root == symbol_boolean) || (is_array (typ) &&
  893.           (root_type (component_type (typ)) == symbol_boolean))) &&
  894.           (streq(selector, "not") || streq(selector, "and")
  895.           || streq(selector, "or") || streq(selector, "xor"))) {
  896.             N_OVERLOADED(n_node) = TRUE;
  897.             N_NAMES(n_node) =
  898.               set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  899.             return TRUE;
  900.         }
  901.         if (is_scalar_type (typ) || (is_array (typ) &&
  902.           is_discrete_type (component_type (typ))) &&
  903.           (streq(selector, "<") || streq(selector, "<=")
  904.           || streq(selector, ">") || streq(selector, ">="))) {
  905.             N_OVERLOADED(n_node) = TRUE;
  906.             N_NAMES(n_node) =
  907.               set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  908.             return TRUE;
  909.         }
  910.         if (is_numeric_type (typ) &&
  911.           (streq(selector, "+") || streq(selector, "-") ||
  912.           streq(selector, "*") || streq(selector, "/") ||
  913.           streq(selector, "**") || streq(selector, "abs") ||
  914.           streq(selector, "mod") || streq(selector, "rem"))) {
  915.             N_OVERLOADED(n_node) = TRUE;
  916.             N_NAMES(n_node) =
  917.                set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  918.             return TRUE;
  919.         }
  920.         if (is_array (typ) && streq (selector , "&")) {
  921.             N_OVERLOADED(n_node) = TRUE;
  922.             N_NAMES(n_node) =
  923.               set_new1((char *)dcl_get(DECLARED(symbol_standard0), selector));
  924.             return TRUE;
  925.         }
  926.     ENDFORDECLARED(fd1);
  927.     return FALSE;
  928. }
  929.  
  930. static void make_any_id_node(Node n_node) /*;make_any_id_node*/
  931. {
  932.     Span    save_span;
  933.  
  934.     save_span = get_left_span(n_node);
  935.     N_KIND(n_node) = as_simple_name;
  936.     N_AST2(n_node) = (Node)0;
  937.     set_span(n_node, save_span);
  938.     N_UNQ(n_node) = symbol_any_id;
  939. }
  940.  
  941. static int is_appropriate_for_record(Symbol t) /*;is_appropriate_for_record*/
  942. {
  943.     return (is_record(t)
  944.         || is_access(t) && is_record(designated_type(t)));
  945. }
  946.  
  947. static int is_appropriate_for_task(Symbol t)        /*;is_appropriate_for_task*/
  948. {
  949.     return (is_task_type(t)
  950.         || is_access(t) && is_task_type(designated_type(t)));
  951. }
  952.  
  953. Set find_agg_types()   /*;find_agg_types*/
  954. {
  955.     /*
  956.      * The possible types of an aggregate  are all the structured types  that
  957.      * are    visible, even if  not directly    visible.
  958.      */
  959.  
  960.     Symbol    s, agg, p, fgn, ss;
  961.     Set    res;
  962.     Fortup    ft1;
  963.     Forset    fs1;
  964.  
  965.     /*
  966.      * return {}  +/[overloads(agg): s in open_scopes
  967.      *               |(agg := declared(s)('aggregate')) /= om]
  968.      *     +/[overloads(fgn) : p in vis_mods
  969.      *               |(fgn :=  visible(p)('aggregate')) /= om];
  970.      */
  971.     res = set_new(0);
  972.     FORTUP(s=(Symbol), open_scopes, ft1);
  973.         agg = dcl_get(DECLARED(s), "aggregate");
  974.         if (agg!=(Symbol)0) {
  975.             FORSET(ss=(Symbol), OVERLOADS(agg), fs1);
  976.                 res = set_with(res, (char *)ss);
  977.             ENDFORSET(fs1);
  978.         }
  979.     ENDFORTUP(ft1);
  980.     FORTUP(p=(Symbol), vis_mods, ft1);
  981.         fgn =  dcl_get_vis(DECLARED(p), "aggregate");
  982.         if (fgn!=(Symbol)0) {
  983.             FORSET(ss=(Symbol), OVERLOADS(fgn), fs1);
  984.                 res = set_with(res, (char *) ss);
  985.             ENDFORSET(fs1);
  986.         }
  987.     ENDFORTUP(ft1);
  988.     return res;
  989. }
  990.  
  991. Set find_access_types() /*;find_access_types*/
  992. {
  993.     /*
  994.      * Similarly, the possible types of NULL, and of any allocator, are all
  995.      * visible access types. To simplify their  retrieval, they are treated
  996.      * like aggregates,  and  attached to the marker  'access', whenever an
  997.      * access type definition is processed.
  998.      */
  999.  
  1000.     Set a_types;
  1001.     Symbol    s, fgn, ss, a;
  1002.     Fortup    ft1;
  1003.     Forset    fs1;
  1004.  
  1005.     /*
  1006.      * a_types =
  1007.      * {} +/[overloads(a): s in open_scopes
  1008.      *               |(a := declared(s)('access')) /= om]
  1009.      *   +/[overloads(fgn) : p in vis_mods
  1010.      *               |(fgn :=  visible(p)('access')) /= om];
  1011.      */
  1012.     a_types = set_new(0);
  1013.     FORTUP(s = (Symbol), open_scopes, ft1);
  1014.         a = dcl_get(DECLARED(s), "access");
  1015.         if (a != (Symbol)0) {
  1016.             FORSET(ss=(Symbol), OVERLOADS(a), fs1);
  1017.                 a_types = set_with(a_types, (char *) ss);
  1018.             ENDFORSET(fs1);
  1019.         }
  1020.     ENDFORTUP(ft1);
  1021.  
  1022.     FORTUP(fgn = (Symbol), vis_mods, ft1);
  1023.         fgn =  dcl_get_vis(DECLARED(fgn), "access");
  1024.         if (fgn != (Symbol)0) {
  1025.             FORSET(ss=(Symbol), OVERLOADS(fgn), fs1);
  1026.                 a_types = set_with(a_types, (char *) ss);
  1027.             ENDFORSET(fs1);
  1028.         }
  1029.     ENDFORTUP(ft1);
  1030.  
  1031.     if (set_size(a_types) == 0) {
  1032.         noop_error = TRUE;
  1033.         errmsg("No available access types for allocator", "3.8,4.8",
  1034.             current_node);
  1035.     }
  1036.     return a_types;
  1037. }
  1038.  
  1039. Symbol find_new(char *name)  /*;find_new*/
  1040. {
  1041.     Symbol    unique_nam, old;
  1042.  
  1043.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  find_new");
  1044.  
  1045.     /*
  1046.      * insert new name in symbol table of current scope. Check
  1047.      * against duplications.
  1048.      *
  1049.      * IF error token was seen ('') , return undeclared marker.
  1050.      */
  1051.  
  1052.     if (name == (char *)0 || strlen(name) == 0) return    symbol_any_id;
  1053.  
  1054.     /* add new name to current scope declarations.
  1055.      * generate a unique identifier for it.
  1056.      */
  1057.  
  1058.     unique_nam = (Symbol) 0;
  1059.  
  1060.     /* Insert new name in DECLARED table for current scope */
  1061.     old = dcl_get(DECLARED(scope_name), name);
  1062.     if (old     != (Symbol)0) {
  1063.         /* The name has been seen already. This is acceptable
  1064.          * if it  was inserted after     some previous    error of
  1065.          * any sort. (in that case it has type 'any').
  1066.          */
  1067.         if    (TYPE_OF(old) == symbol_any) return old;
  1068.         else {
  1069. #ifdef ERRNUM
  1070.             str_errmsgn(431, name, 143, current_node);
  1071. #else
  1072.             errmsg_str("duplicate identifier: %", name , "8.3", current_node);
  1073. #endif
  1074.         }
  1075.     }
  1076.     else {
  1077.         unique_nam = sym_new(na_void);
  1078.         /* insert in declared map for scope, and make visible if scope
  1079.           * is a package specification. ES 9-21-86)
  1080.           */
  1081.         dcl_put_vis(DECLARED(scope_name), name, unique_nam ,
  1082.           (NATURE(scope_name) == na_package_spec));
  1083.     }
  1084.     /* Initialize symbol table entry.*/
  1085.     /* allocate new symbol if not yet allocated */
  1086.     if (unique_nam == (Symbol)0) unique_nam = sym_new(na_void);
  1087.     NATURE(unique_nam)  = na_void;
  1088.     TYPE_OF(unique_nam)  = symbol_none;
  1089.     SCOPE_OF(unique_nam) = scope_name;
  1090.     ORIG_NAME(unique_nam) = name;
  1091.     TO_XREF(unique_nam);
  1092.     return unique_nam;
  1093. }
  1094.  
  1095. void check_void(char *id)  /*;check_void*/
  1096. {
  1097.     /*
  1098.      * Verify that within a procedure specification no use is made of the
  1099.      * procedure identifier under any guise. This cannot be automatically
  1100.      * caught by the name resolution routines.
  1101.      */
  1102.     if (streq(original_name(scope_name), id) && NATURE(scope_name) == na_void){
  1103. #ifdef ERRNUM
  1104.         str_errmsgn(425, id, 50, current_node);
  1105. #else
  1106.         errmsg_str("premature usage of %", id, "8.3(16)", current_node);
  1107. #endif
  1108.     }
  1109. }
  1110.  
  1111. /* new_agg_or_access becomes two procedures:
  1112.     new_agg_or_access_acc    marker 'access' implied
  1113.     new_agg_or_access_agg    marker 'aggregate' implied
  1114.  */
  1115.  
  1116. void new_agg_or_access_acc(Symbol type_mark)  /*;new_agg_or_access_acc*/
  1117. {
  1118.     /*
  1119.      * The possible types of an aggregate are all composite types that are
  1120.      * currently visible. To simplify their use, an entry  with the marker
  1121.      * 'aggregate' is created for each such type definition. Its overloads
  1122.      * set carries all such types  defined in  the current    scope. This is
  1123.      * similar to what is done for other overloadable constructs.
  1124.      * The same is done for access types, using the marker 'access'.
  1125.      */
  1126.  
  1127.     Symbol    scope, old_def, new_def, maybe_priv, pr;
  1128.     int    nat;
  1129.     Private_declarations pd;
  1130.  
  1131.     if (cdebug2>3) TO_ERRFILE("AT PROC: new_agg_or_access_acc");
  1132.  
  1133.     scope = scope_name;
  1134.     nat = na_access    ;
  1135.     new_def = sym_new(nat);
  1136. #ifdef TBSN
  1137.     new_def = marker + str newat;
  1138. #endif
  1139.     SCOPE_OF(new_def) = scope;
  1140.     TYPE_OF(new_def)  = type_mark;
  1141.     old_def = dcl_get(DECLARED(scope), "access");
  1142.     if (old_def == (Symbol)0 ) {     /* first in scope*/
  1143.         dcl_put(DECLARED(scope), "access", new_def );
  1144.         OVERLOADS(new_def) = set_new1((char *) type_mark);
  1145.     }
  1146.     else {
  1147.         dcl_put(DECLARED(scope), newat_str(), new_def);
  1148.         /* If the current scope is  a private part, make sure the visible
  1149.          * declaration has been saved, before adding new entry to overloads
  1150.          * set for old_def.
  1151.          */
  1152.         pd = (Private_declarations) private_decls(scope);
  1153.         if (NATURE(scope_name) == na_private_part
  1154.           && private_decls_get(pd, old_def) == (Symbol)0)
  1155.             private_decls_put(pd, old_def);
  1156.         OVERLOADS(old_def) = set_with(OVERLOADS(old_def), (char *) type_mark);
  1157.     }
  1158.     /*
  1159.      * If the type has an incomplete private component, (a private ancestor)
  1160.      * list it in the set of private dependents of that ancestor.
  1161.      */
  1162.     maybe_priv =  (Symbol) designated_type(type_mark);
  1163.     pr = private_ancestor(maybe_priv);
  1164.     if ((pr !=(Symbol)0 && in_open_scopes(SCOPE_OF(pr)))
  1165.       || (is_access(type_mark) && is_incomplete_type(pr = maybe_priv)))
  1166.         /* ie still incomplete.*/
  1167.         if (!private_dependents(pr))
  1168.             private_dependents(pr) = set_new1((char *) type_mark);
  1169.         else
  1170.             private_dependents(pr) =
  1171.               set_with(private_dependents(pr), (char *) type_mark);
  1172.     initialize_representation_info(type_mark,TAG_ACCESS);
  1173. }
  1174.  
  1175. void new_agg_or_access_agg(Symbol type_mark)  /*;new_agg_or_access_agg*/
  1176. {
  1177.     /*
  1178.      * The possible types of an aggregate are all composite types that are
  1179.      * currently visible. To simplify their use, an entry  with the marker
  1180.      * 'aggregate' is created for each such type definition. Its overloads
  1181.      * set carries all such types  defined in  the current    scope. This is
  1182.      * similar to what is done for other overloadable constructs.
  1183.      * The same is done for access types, using the marker 'access'.
  1184.      */
  1185.  
  1186.     Symbol    scope, old_def, new_def, maybe_priv, pr;
  1187.     int    nat;
  1188.     Private_declarations pd;
  1189.  
  1190.     scope = scope_name;
  1191.     nat = na_aggregate;
  1192.     new_def = sym_new(nat);
  1193. #ifdef TBSN
  1194.     if (cdebug2>3) TO_ERRFILE("AT PROC: new_agg_or_access_agg");
  1195.     new_def = marker + str newat;
  1196. #endif
  1197.     SCOPE_OF(new_def) = scope;
  1198.     TYPE_OF(new_def)  = type_mark;
  1199.     old_def = dcl_get(DECLARED(scope), "aggregate");
  1200.     if (old_def == (Symbol)0 ) { /* first in scope*/
  1201.         dcl_put(DECLARED(scope), "aggregate", new_def );
  1202.         OVERLOADS(new_def) = set_new1((char *) type_mark);
  1203.     }
  1204.     else {
  1205.         dcl_put(DECLARED(scope), newat_str(), new_def);
  1206.         /* If the current scope is  a private part, make sure the visible
  1207.          * declaration has been saved, before adding new entry to overloads
  1208.          * set for old_def.
  1209.          */
  1210.         pd = (Private_declarations) private_decls(scope);
  1211.         if (NATURE(scope_name) == na_private_part
  1212.           && private_decls_get(pd, old_def) == (Symbol)0)
  1213.             private_decls_put(pd, old_def);
  1214.         /*
  1215.          * Make a copy of the overloads set so that if the field is 
  1216.          * changed it will not affect another copy of the symbol which 
  1217.          * points to this set. This might be the case if we have compilation
  1218.          * units for a package spec and body in the same file. The Overloads
  1219.          * field pointed to by the "aggregate" symbol saved in the unitdecl 
  1220.          * of the spec and restored when processing the body is mangled if
  1221.          * the body adds anything to this overloads field.
  1222.          */
  1223.         OVERLOADS(old_def) = set_copy(OVERLOADS(old_def));
  1224.         OVERLOADS(old_def) = set_with (OVERLOADS(old_def), (char *) type_mark);
  1225.     }
  1226.     /* If the type has an incomplete private component, (a private ancestor)
  1227.      * list it in the set of private dependents of that ancestor.
  1228.      */
  1229.     maybe_priv = type_mark;
  1230.     pr = private_ancestor(maybe_priv);
  1231.     if ((pr !=(Symbol)0 && in_open_scopes(SCOPE_OF(pr)))
  1232.       || (is_access(type_mark) && is_incomplete_type(pr = maybe_priv)))
  1233.         /* ie still incomplete.*/
  1234.         if (!private_dependents(pr))
  1235.             private_dependents(pr) = set_new1((char *) type_mark);
  1236.         else
  1237.             private_dependents(pr) =
  1238.               set_with(private_dependents(pr), (char *) type_mark);
  1239. }
  1240.  
  1241. char *original_name(Symbol unique_nam)     /*;*original_name*/
  1242. {
  1243.     /*
  1244.      * This procedure strips the prefix and suffix of a generated name, to
  1245.      * recover the original source name. Is is used when looking for a
  1246.      * compilation stub, and for error messages.
  1247.      */
  1248.     return ORIG_NAME(unique_nam);
  1249. }
  1250.  
  1251. /*
  1252.  * Process  RENAMES clauses. If the renamed entity is an identifier, then
  1253.  * the renames clause simply creates a synonym : new id shares the symbol
  1254.  * table entry of the  entity. If  the entity  is an expression, then the
  1255.  * interpreter    will have  to elaborate it, and a  'renames' statement is
  1256.  * emitted. In addition, a new symbol table entry  is created for the new
  1257.  * id, with the the appropriate type and nature.
  1258.  */
  1259. void rename_ex(Node node)      /*;rename_ex*/
  1260. {
  1261.     /* Rename an exception.*/
  1262.     Node    id_node, name_node;
  1263.     char    *new_id;
  1264.     Symbol    old;
  1265.  
  1266.     id_node = N_AST1(node);
  1267.     name_node = N_AST2(node);
  1268.     new_id = N_VAL(id_node);
  1269.     adasem(name_node);
  1270.     find_old(name_node);
  1271.     old = N_UNQ(name_node);
  1272.     if (N_KIND(name_node) != as_simple_name) {
  1273. #ifdef ERRNUM
  1274.         errmsgn(432, 433, name_node);
  1275. #else
  1276.         errmsg("Expect identifier in renaming", "8.5", name_node);
  1277. #endif
  1278.     }
  1279.     else if (N_OVERLOADED(name_node) || NATURE(old) != na_exception) {
  1280. #ifdef ERRNUM
  1281.         errmsgn(434, 433, name_node);
  1282. #else
  1283.         errmsg("not an exception", "8.5", name_node);
  1284. #endif
  1285.     }
  1286.     else
  1287.         dcl_put(DECLARED(scope_name), new_id, old);
  1288. }
  1289.  
  1290. void rename_pack(Node node)  /*;rename_pack*/
  1291. {
  1292.     Node    id_node, name_node;
  1293.     char    *new_id;
  1294.     Symbol    old;
  1295.  
  1296.     id_node = N_AST1(node);
  1297.     name_node = N_AST2(node);
  1298.     new_id = N_VAL(id_node);
  1299.     adasem(name_node);
  1300.     find_old(name_node);
  1301.     old = N_UNQ(name_node);
  1302.     if (N_KIND(name_node) != as_simple_name) {
  1303. #ifdef ERRNUM
  1304.         errmsgn(432, 433, name_node);
  1305. #else
  1306.         errmsg("Expect identifier in renaming", "8.5", name_node);
  1307. #endif
  1308.     }
  1309.     else if (N_OVERLOADED(name_node)
  1310.       || (NATURE(old) != na_package
  1311.       &&  NATURE(old) != na_package_spec
  1312.       &&  NATURE(old) != na_generic_package
  1313.       &&  NATURE(old) != na_generic_package_spec)) {
  1314. #ifdef ERRNUM
  1315.         errmsgn(435, 433, name_node);
  1316. #else
  1317.         errmsg("not a package", "8.5", name_node);
  1318. #endif
  1319.     }
  1320.     else
  1321.         dcl_put(DECLARED(scope_name), new_id, old);
  1322. }
  1323.  
  1324. void rename_subprogram(Node node)                    /*;rename_subprogram*/
  1325. {
  1326.     /*
  1327.      * The subprogram specification is elaborated, and the declared subpro-
  1328.      * gram is inserted in the symbol table.
  1329.      */
  1330.     Symbol    ret;
  1331.     Node    spec_node, name_node, formal_list;
  1332.     int        kind, s_kind, exists, i;
  1333.     Node    id_node, ret_node;
  1334.     Tuple    formals, ftup, old_types;
  1335.     Symbol    old1;
  1336.     Set        set;
  1337.     Symbol    ne, new_subp, new_ne;
  1338.     Forset    fs1;
  1339.     Fortup    ft1;
  1340.     char    *id;
  1341.  
  1342.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  rename_subprogram");
  1343.  
  1344.     spec_node = N_AST1(node);
  1345.     name_node = N_AST2(node);
  1346.     adasem(spec_node);
  1347.     id_node = N_AST1(spec_node);
  1348.     formal_list = N_AST2(spec_node);
  1349.     ret_node = N_AST3(spec_node);
  1350.     id = N_VAL(id_node);
  1351.     formals = get_formals(formal_list, id);
  1352.  
  1353.     if (N_KIND(spec_node) == as_procedure ) {
  1354.         kind = na_procedure;
  1355.         s_kind = na_procedure_spec;
  1356.         ret = symbol_none;
  1357.         /* Transform into abbreviated as_rename_sub_tr node and reset
  1358.          * N_UNQ(node) in later code below. The spec part of the node
  1359.          * is dropped.
  1360.          */
  1361.         N_KIND(node) = as_rename_sub_tr;
  1362.     }
  1363.     else {
  1364.         kind = na_function;
  1365.         s_kind = na_function_spec;
  1366.         ret = N_UNQ(ret_node);
  1367.         N_KIND(node) = as_rename_sub_tr;
  1368.         /* reset N_UNQ(node) below */
  1369.     }
  1370.     adasem(name_node);
  1371.     find_old(name_node); /* Name of entity being renamed.*/
  1372.  
  1373.     current_node = node;
  1374.     old_types = find_renamed_entity(kind, formals, ret, name_node);
  1375.     if (tup_size(old_types) != 0) {
  1376.         /* the subtypes of the formals are unaffected by the renaming */
  1377.         ret = (Symbol) tup_frome(old_types);
  1378.         FORTUPI(ftup = (Tuple), formals, i, ft1);
  1379.             ftup[3] = (char *)old_types[i];
  1380.         ENDFORTUP(ft1);
  1381.     }
  1382.     else return;        /* previous error. Is this ok ??? */
  1383.  
  1384.     if (N_KIND(name_node) == as_simple_name) {
  1385.         /* renaming of subprogram or operator. */
  1386.         old1 = N_UNQ(name_node);
  1387.         if (in_op_designators(id ))  /* check format, if operator spec */
  1388.             check_new_op(id_node, formals, ret);
  1389.  
  1390.         new_subp = chain_overloads(id, s_kind, ret, formals, old1, OPT_NODE);
  1391.         N_UNQ(node) = new_subp;
  1392.         /* a renaming is both a specification and body */
  1393.         NATURE(new_subp) = kind;
  1394.         if (ALIAS(old1) != (Symbol)0)
  1395.             ALIAS(new_subp) = ALIAS(old1);
  1396.         else
  1397.             ALIAS(new_subp) = old1;
  1398.         if (streq(id , "=")) {
  1399.             if (!streq(original_name(old1) , "=")) {
  1400. #ifdef ERRNUM
  1401.                 errmsgn(436, 54, name_node);
  1402. #else
  1403.                 errmsg("renaming with = can only rename an equality operator",
  1404.                   "6.7", name_node);
  1405. #endif
  1406.             }
  1407.             else if (tup_size(formals) != 2 ) {
  1408.                 ;    /* error caught elsewhere*/
  1409.             }
  1410.             else {
  1411.                 /* The implicitly defined inequality operator, just introduced,
  1412.                  * renames another inequality.  assert exists ne in
  1413.                  * overloads(declared(scope_of(old1))('/=')) |
  1414.                  *        same_signature(old1, ne);
  1415.                  */
  1416.                 exists = FALSE;
  1417.                 set = OVERLOADS(dcl_get(DECLARED(SCOPE_OF(old1)), "/="));
  1418.                 FORSET(ne=(Symbol), set, fs1);
  1419.                     if(same_signature(old1, ne)) {
  1420.                         exists = TRUE;
  1421.                         break;
  1422.                     }
  1423.                 ENDFORSET(fs1);
  1424.                 if (!exists)
  1425.                     chaos("assertion failed in rename_subprogram chapter 8");
  1426.                 /* assert exists new_ne in
  1427.                  * overloads(declared(scope_of(new_subp))('/=')) |
  1428.                  *      same_signature(new_subp, new_ne);
  1429.                  */
  1430.                 exists = FALSE;
  1431.                 set = OVERLOADS(dcl_get(DECLARED(SCOPE_OF(new_subp)), "/="));
  1432.                 FORSET(new_ne=(Symbol), set, fs1);
  1433.                     if(same_signature(new_subp, new_ne)) {
  1434.                         exists = TRUE;
  1435.                         break;
  1436.                     }
  1437.                 ENDFORSET(fs1);
  1438.  
  1439.                 if (!exists)
  1440.                     chaos("assertion failed in rename_subprogram chapter 8");
  1441.  
  1442.                 if (ALIAS(ne) != (Symbol) 0)
  1443.                     ALIAS(new_ne) = ALIAS(ne);
  1444.                 else
  1445.                     ALIAS(new_ne) = ne;
  1446.             }
  1447.         }
  1448.     }
  1449.     else {
  1450.         /* renaming of entry or attribute. */
  1451.  
  1452.         new_subp= chain_overloads(id, s_kind, ret, formals, (Symbol)0,OPT_NODE);
  1453.         N_UNQ(node) = new_subp;
  1454.     }
  1455.     /* A renaming declaration provides the subprogram specification and the
  1456.      * body as well.
  1457.      */
  1458.     NATURE(new_subp) = kind;
  1459. }
  1460.  
  1461. Tuple find_renamed_entity(int kind, Tuple formals, Symbol ret, Node name_node)
  1462. /*;find_renamed_entity*/
  1463. {
  1464.     /* When a subprogram  is renamed, the  signature of the entity is that of
  1465.      * the renamed object, and not that of the given subprogram specification
  1466.      * (except if the  renamed entity is an operator, in  which case the base
  1467.      * types of the specification are used).
  1468.      * This procedure finds    the renamed  entity (subprogram, entry or attri-
  1469.      * bute, verifies that it matches  the spec, and returns a tuple with the
  1470.      * types of  the formals     of the renamed object, together with  its type.
  1471.      */
  1472.     Symbol    old1, e_name, typ, typ2, res, ft, i;
  1473.     Set        old_sub;
  1474.     Node        e_node, attr_node, typ_node;
  1475.     int        attr;
  1476.     Tuple    tup, ftup;
  1477.     Fortup    ft1;
  1478.     Span        save_span;
  1479.  
  1480.     if (N_OVERLOADED(name_node)) {
  1481.         old_sub = N_NAMES(name_node);        /* Most likely overloadable. */
  1482.         /* find the one that matches the new specification. */
  1483.         old1 = renamed(name_node, formals, ret);
  1484. #ifdef TBSL
  1485.         -- check old1='' in next line
  1486. #endif
  1487.         if (old1 == (Symbol) 0) return tup_new(0);    /* No match found. */
  1488.         else {
  1489.             /* suprogram name renames subprogram name. Mark as simple */
  1490.             /* renaming. */
  1491.             save_span = get_left_span(name_node);
  1492.             ast_clear(name_node);
  1493.             N_KIND(name_node) = as_simple_name;
  1494.             set_span(name_node, save_span);
  1495.             N_UNQ(name_node)  = old1;
  1496.             tup = tup_new(0);
  1497.             if (NATURE(old1) != na_op) {
  1498.                 FORTUP(i=(Symbol), SIGNATURE(old1), ft1);
  1499.                     tup = tup_with(tup, (char *) TYPE_OF(i));
  1500.                 ENDFORTUP(ft1);
  1501.                 tup = tup_with(tup, (char *) TYPE_OF(old1));
  1502.             }
  1503.             else {
  1504.                 FORTUP(ftup=(Tuple), formals, ft1);
  1505.                     tup = tup_with(tup, (char *) base_type((Symbol) ftup[3]));
  1506.                 ENDFORTUP(ft1);
  1507.                 tup = tup_with(tup, (char *) base_type(ret));
  1508.             }
  1509.             return tup;
  1510.         }
  1511.     }
  1512.     else if (kind == na_procedure &&
  1513.       (N_KIND(name_node) == as_selector || N_KIND(name_node)== as_index)) {
  1514.         /* Procedure renames a entry given by a qualified name. Find */
  1515.         /* the full entry (and task) name. */
  1516.         renamed_entry(name_node, formals);
  1517.         e_node = N_AST2(name_node);
  1518.         if (e_node != OPT_NODE) {
  1519.             e_name = N_UNQ(e_node);
  1520. #ifdef TBSL
  1521.             return [type_of(i): i in signature(e_name)] with 'none';
  1522. #endif
  1523.             tup = tup_new(0);
  1524.             FORTUP(i=(Symbol), SIGNATURE(e_name), ft1)
  1525.                 tup = tup_with(tup, (char *) TYPE_OF(i));
  1526.             ENDFORTUP(ft1)
  1527.             tup = tup_with(tup, (char *) symbol_none);
  1528.         }
  1529.         else {
  1530.             return tup_new(0);
  1531.         }
  1532.     }
  1533.     else    {
  1534.         /* The name can be an attribute, renaming a function. */
  1535.         /* Verify that signatures match. */
  1536.         if (kind != na_function || N_KIND(name_node) != as_attribute) {
  1537. #ifdef ERRNUM
  1538.             errmsgn(437, 433, name_node);
  1539. #else
  1540.             errmsg("invalid renaming", "8.5", name_node);
  1541. #endif
  1542.             return tup_new(0);
  1543.         }
  1544.         else if (tup_size(formals) != 1) {
  1545. #ifdef ERRNUM
  1546.             errmsgn(438, 439, current_node);
  1547. #else
  1548.             errmsg("function spec. does not match attribute", "8.5,12.3.6",
  1549.               current_node);
  1550. #endif
  1551.             return tup_new(0);
  1552.         }
  1553.  
  1554.         attr_node = N_AST1(name_node);
  1555.         typ_node = N_AST2(name_node);
  1556.         attr = (int) N_VAL(attr_node);
  1557.         typ     = N_UNQ(typ_node);
  1558.         tup     = (Tuple) formals[1];     /* verify that this is correct  */
  1559.         ft   = (Symbol)tup[3];
  1560.         /* Find type returned by the attribute, and the required type of its
  1561.          * second argument.
  1562.          */
  1563.  
  1564.         if (attr == ATTR_SUCC || attr == ATTR_PRED) {
  1565.             typ2 = base_type(typ);
  1566.             res = base_type(typ);
  1567.         }
  1568.         else if (attr == ATTR_IMAGE) {
  1569.             typ2 = base_type(typ);
  1570.             res = symbol_string;
  1571.         }
  1572.         else if (attr == ATTR_VALUE) {
  1573.             typ2 = symbol_string;
  1574.             res = base_type(typ);
  1575.         }
  1576.         else {
  1577. #ifdef ERRNUM
  1578.             errmsgn(440, 439, attr_node);
  1579. #else
  1580.             errmsg("attribute cannot be renamed as function", "8.5,12.3.6",
  1581.               attr_node);
  1582. #endif
  1583.             return tup_new(0);
  1584.         }
  1585.         if (!compatible_types(ret, res) ||
  1586.           !compatible_types(typ2, ft)) {
  1587. #ifdef ERRNUM
  1588.             errmsgn(438, 439, current_node);
  1589. #else
  1590.             errmsg("function spec. does not match attribute", "8.5,12.3.6",
  1591.               current_node);
  1592. #endif
  1593.             return tup_new(0);
  1594.         }
  1595.         else {
  1596.             tup = tup_new(2);
  1597.             tup[1] = (char *) typ2;
  1598.             tup[2] = (char *) res;
  1599.             return tup;
  1600.         }
  1601.     }
  1602. }
  1603.  
  1604. void rename_object(Node node)  /*;rename_object*/
  1605. {
  1606.     Node    id_node, type_node, expr_node;
  1607.     char    *new_id;
  1608.     Symbol    typ, new_obj, obj_typ;
  1609.     Node    old_expr = (Node) 0; /* see note below */
  1610.     int    nat;
  1611.     Tuple    tup;
  1612.  
  1613.     if (cdebug2 > 3)
  1614.         TO_ERRFILE("AT PROC :  rename_object");
  1615.  
  1616.     id_node = N_AST1(node);
  1617.     type_node = N_AST2(node);
  1618.     expr_node = N_AST3(node);
  1619.     new_id = N_VAL(id_node);
  1620.     adasem(type_node);
  1621.     adasem(expr_node);
  1622.     find_old(expr_node);
  1623.     typ = find_type(type_node);
  1624.  
  1625.     out_context = TRUE; /* Subcomponents of out parameters*/
  1626.     check_type(typ, expr_node);
  1627.     out_context = FALSE; /* are certainly renamable.*/
  1628.  
  1629.     if (in_qualifiers(N_KIND(expr_node))) {
  1630.         /* Constraints implied by the type mark of the clause are ignored*/
  1631.         expr_node = N_AST1(expr_node);
  1632.         N_AST1(node) = id_node;
  1633.         N_AST2(node) = type_node;
  1634.         N_AST3(node) = expr_node;
  1635.     }
  1636.     /* It is tempting to say that if a simple object is being renamed, the
  1637.      * new one has the same unique name. This simple optimization must
  1638.      * however be delayed until after conformance checks have been done.
  1639.      */
  1640.     /* TBSL - old_expr is never initialized. However
  1641.      * is_discriminant_dependent(12) currently always returns FALSE, so we
  1642.      * just declare old_expr.        ds 3 aug
  1643.      * old_expr is initialized to (Node) 0 to keep lint quite  ds 23-feb-87
  1644.      */
  1645.     if (is_discriminant_dependent( old_expr )) {
  1646. #ifdef ERRNUM
  1647.         str_errmsgn(441, new_id, 433, (Node)0);
  1648. #else
  1649.         errmsg_str("existence of object % depends on a discriminant ", new_id,
  1650.           "8.5", (Node)0);
  1651. #endif
  1652.     }
  1653.     else {
  1654.         new_obj = find_new(new_id);
  1655.         N_UNQ(id_node) = new_obj;
  1656.         tup = check_nat_type(expr_node);
  1657.         nat = (int) tup[1];
  1658.         obj_typ = (Symbol) tup[2];
  1659.         if (N_KIND(expr_node) == as_slice) {
  1660.             obj_typ = slice_type(node,1);
  1661.         }
  1662.         NATURE(new_obj)  = nat;
  1663.         SIGNATURE(new_obj) = (Tuple)expr_node;
  1664.         TYPE_OF(new_obj) = typ;
  1665.         if (N_KIND(expr_node) != as_ivalue) {
  1666.              /* object sharing at run-time. The type is inherited from the
  1667.               * object (the declared type may be unconstrained).
  1668.              */
  1669.             TYPE_OF(new_obj) = obj_typ;
  1670.         /* In the C version constants are allocated and this is handled
  1671.          * during the code generation phase.
  1672.          */
  1673.         }
  1674.     }
  1675. }
  1676.  
  1677. static Symbol renamed(Node name_node, Tuple formals, Symbol ret)    /*;renamed*/
  1678. {
  1679.     Node    arg_list_node, subp_node, arg, expn;
  1680.     Set        sfound, types, nset, tset, subprogs;
  1681.     Symbol    subp, n, t, found;
  1682.     Tuple    arg_list, ftup;
  1683.     Fortup    ft1;
  1684.     Forset    fs1;
  1685.     int        exists;
  1686.  
  1687.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  renamed");
  1688.  
  1689.     /* Find the subprogram in the overloaded set -subprog- which matches
  1690.      * the specification given in a renames clause or in a generic instantia-
  1691.      * tion.
  1692.      * If subprogs includes operators, then the matching is analogous to the
  1693.      * type-checking of an expression. We construct a skeletal argument list
  1694.      * out of the formals, and use result-types(q.v) to find the specific
  1695.      * operator being renamed.
  1696.      */
  1697.     if (cdebug2 > 0) TO_ERRFILE("Renaming prog with signature " );
  1698.  
  1699.     subp_node = copy_tree(name_node);
  1700.     subprogs  = set_new(0);
  1701.  
  1702.     /* The renamed subprogram and the given specification must have the same
  1703.      * parameter and result profile. This requires that signatures have the
  1704.      * same length, and that the types match. Type matching is verified by
  1705.      * constructing a call to the renamed entity. Length checking is done first.
  1706.      */
  1707.     FORSET(subp=(Symbol), N_NAMES(subp_node), fs1)
  1708.         if (NATURE(subp) == na_op
  1709.           || tup_size(SIGNATURE(subp)) == tup_size(formals))
  1710.             subprogs = set_with(subprogs, (char *)subp);
  1711.     ENDFORSET(fs1);
  1712.     N_NAMES(subp_node) = subprogs;
  1713.  
  1714.     arg_list_node = node_new(as_list);
  1715.     arg_list = tup_new(0);
  1716.     FORTUP(ftup=(Tuple), formals, ft1);
  1717.         t = (Symbol) ftup[3];
  1718.         arg = node_new(as_simple_name);
  1719.         N_PTYPES(arg) = set_new1((char *) t);
  1720.         arg_list = tup_with(arg_list, (char *) arg);
  1721.     ENDFORTUP(ft1);
  1722.     N_LIST(arg_list_node) = arg_list;
  1723.  
  1724.     /* Build call node with these arguments, and resolve. */
  1725.     expn = node_new(as_call);
  1726.     N_AST1(expn) = subp_node;
  1727.     N_AST2(expn) = arg_list_node;
  1728.     result_types(expn);
  1729.     types = N_PTYPES(expn);
  1730.     N_PTYPES(expn) = (Set) 0; /* clear */
  1731.     if (types == (Set)0)  types = set_new(0);
  1732.     sfound = set_new(0);
  1733.     if (N_OVERLOADED(subp_node))
  1734.         nset = N_NAMES(subp_node);
  1735.     else
  1736.         nset = (Set) 0;
  1737.     if (nset!=(Set)0) {
  1738.         FORSET(n=(Symbol), nset, fs1);
  1739.             if (compatible_types(TYPE_OF(n), ret))
  1740.                 sfound = set_with(sfound, (char *) n);
  1741.         ENDFORSET(fs1);
  1742.     }
  1743.     /* This may require a stronger test.*/
  1744.     if (set_size(sfound) > 1) {
  1745.         /* user-defined subprogram defined in enclosing scope hides predefined
  1746.           * operator, and is chosen first.
  1747.           */
  1748.         exists = FALSE;
  1749.         FORSET(subp=(Symbol), sfound, fs1);
  1750.             if (NATURE(subp) != na_op
  1751.               && tup_mem((char *) SCOPE_OF(subp) , open_scopes)) {
  1752.                 exists = TRUE;
  1753.                 break;
  1754.             }
  1755.         ENDFORSET(fs1);
  1756.         if (exists) {
  1757.             tset = set_new(0);
  1758.             FORSET(subp=(Symbol), sfound, fs1);
  1759.                 if (NATURE(subp) != na_op)
  1760.                     tset = set_with(tset, (char *) subp);
  1761.             ENDFORSET(fs1);
  1762.             set_free(sfound);
  1763.             sfound = tset;
  1764.         }
  1765.         else {
  1766.             FORSET(subp=(Symbol), sfound, fs1);
  1767.                 if ( NATURE(subp) == na_op) {
  1768.                     sfound = set_new1((char *) subp);
  1769.                     break;
  1770.                 }
  1771.             ENDFORSET(fs1);
  1772.         }
  1773.     }
  1774.     if (set_size(sfound) == 1 ) {
  1775.         found = (Symbol) set_arb( sfound);
  1776.         check_modes(formals, found);
  1777.  
  1778.         if (cdebug2 > 0) TO_ERRFILE("renaming successful with ...");
  1779.  
  1780.         return found;
  1781.     }
  1782.     else if (set_size(sfound) > 1 ) {
  1783. #ifdef ERRNUM
  1784.         id_errmsgn(442, (Symbol)set_arb(subprogs), 439, current_node);
  1785. #else
  1786.         errmsg_id("ambiguous subprogram name: %", (Symbol) set_arb(subprogs),
  1787.           "8.5,12.3.6", current_node);
  1788. #endif
  1789.     }
  1790.     else {
  1791. #ifdef ERRNUM
  1792.         errmsgn(443, 439, current_node);
  1793. #else
  1794.         errmsg("No match for subprogam specification ", "8.5,12.3.6",
  1795.           current_node);
  1796. #endif
  1797.     }
  1798.     return (Symbol)0;
  1799. }
  1800.  
  1801. static Symbol op_matches_spec(Symbol op_nam, Tuple f_types, Symbol ret)
  1802. /*;op_matches_spec*/
  1803. {
  1804.     /* Determine whether a predefined operator matches a given subprogram
  1805.      * specification. Called for renamings and for name resolution of
  1806.      * selected components whose selector is an operator designator.
  1807.      * The matching is analogous to the type-checking of an expression. We
  1808.      * construct a skeletal argument list out of the type of formals, and
  1809.      * use result-types(q.v) to find the specific operator being renamed.
  1810.      */
  1811.     Node    op_node, arg_list_node, expn;
  1812.     Tuple    arg_list;
  1813.     Symbol    t;
  1814.     Fortup    ft1;
  1815.     Forset  fs1;
  1816.     Set    ops, types;
  1817.     Node    arg;
  1818.  
  1819.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : op_matches_spec");
  1820.  
  1821.     if (tup_size(f_types) < 1 || tup_size(f_types)> 2 )
  1822.         return (Symbol)0;
  1823.     else {
  1824.         op_node = node_new(as_op);
  1825.         N_NAMES(op_node) = set_new1((char *) op_nam);
  1826.         N_OVERLOADED(op_node) = TRUE;
  1827.  
  1828.         arg_list_node = node_new(as_list);
  1829.         arg_list = tup_new(0);
  1830.         FORTUP(t=(Symbol), f_types, ft1);
  1831.             arg = node_new(as_simple_name);
  1832.             N_PTYPES(arg) = set_new1((char *) t);
  1833.             arg_list = tup_with(arg_list, (char *) arg);
  1834.         ENDFORTUP(ft1);
  1835.         N_LIST(arg_list_node) = arg_list;
  1836.  
  1837.         expn = node_new(as_call);
  1838.         N_AST1(expn) = op_node;
  1839.         N_AST2(expn) = arg_list_node;
  1840.         result_types(expn);
  1841.         ops =  (N_OVERLOADED(op_node)) ? N_NAMES(op_node): (Set)0;
  1842.         types = N_PTYPES(expn);
  1843.         N_PTYPES(expn) = (Set)0; /* clear */
  1844.  
  1845.         if (ops == (Set)0) return (Symbol) 0;
  1846.         if (set_size(ops) != 1) return (Symbol) 0;
  1847.         FORSET(t=(Symbol), types, fs1);
  1848.             if (compatible_types(t, ret)) return (Symbol) set_arb(ops);
  1849.         ENDFORSET(fs1);
  1850.         return (Symbol) 0;
  1851.     }
  1852. }
  1853.  
  1854. static void check_modes(Tuple formals, Symbol subp)      /*;check_modes*/
  1855. {
  1856.     /* Verify that the modes of the formals in a renaming spec match the modes
  1857.      * of the renamed subprogram (operator, entry).
  1858.      */
  1859.  
  1860.     int        i, md;
  1861.     Fortup    ft1;
  1862.     Tuple    tup, sig;
  1863.  
  1864.     sig = SIGNATURE(subp);
  1865.     FORTUPI(tup=(Tuple), formals, i, ft1);
  1866.         md = (int) tup[2];
  1867.         if ((NATURE(subp) == na_op && md == na_in)
  1868.           || md == NATURE((Symbol)sig[i]))
  1869.             ;
  1870.         else {
  1871. #ifdef ERRNUM
  1872.             errmsgn(444, 445, current_node);
  1873. #else
  1874.             errmsg("parameter modes do not match", "8.5(8)", current_node);
  1875. #endif
  1876.         }
  1877.     ENDFORTUP(ft1);
  1878. }
  1879.  
  1880. static void renamed_entry(Node entry_expr, Tuple formals)     /*;renamed_entry*/
  1881. {
  1882.     /* A procedure is being renamed with an expression. This can only be the
  1883.      * renaming of an entry or a member of an entry family.
  1884.      */
  1885.  
  1886.     Symbol    e, new_typ, i_type;
  1887.     Set entries, found    ;
  1888.     Tuple    tup;
  1889.     Symbol    e_name;
  1890.     Node    task_node, entry_node, index_node;
  1891.     Fortup    ft1;
  1892.     Forset    fs1;
  1893.     Tuple    sig;
  1894.     int    i, nk;
  1895.     Symbol    f;
  1896.  
  1897.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  renamed_entry");
  1898.  
  1899.     find_entry_name(entry_expr);
  1900.     task_node  = N_AST1(entry_expr);
  1901.     entry_node = N_AST2(entry_expr);
  1902.  
  1903.     if (entry_node == OPT_NODE)  /* Invalid entry name or expression*/
  1904.         return;
  1905.     else if (N_KIND(entry_expr) == as_entry_name) {
  1906.         /* possibly  overloaded; disambiguate with signature. */
  1907.         entries = N_NAMES(entry_expr);
  1908.         N_AST3(entry_expr) = OPT_NODE;   /* discard N_NAMES */
  1909.     }
  1910.     else { /* case of entry family member. Type check the index */
  1911.         e_name     = N_UNQ(entry_node);
  1912.         entries    = set_new1((char *) e_name);
  1913.         index_node = N_AST3(entry_expr);
  1914.         i_type     = (Symbol) index_type(TYPE_OF(e_name));
  1915.         check_type(i_type, index_node);
  1916.         N_KIND(entry_expr) = as_entry_name; /* common processing after this*/
  1917.     }
  1918.     found = set_new(0);
  1919.  
  1920.     FORSET(e=(Symbol), entries, fs1);
  1921.         sig = SIGNATURE(e);
  1922.         if (tup_size( sig) != tup_size(formals)) continue;
  1923.  
  1924.         FORTUPI(f =(Symbol), sig, i, ft1);
  1925.             tup = (Tuple) formals[i];
  1926.             new_typ = (Symbol) tup[3];
  1927.             if (!same_type(TYPE_OF(f), new_typ)) goto continue_forall_e;
  1928.         ENDFORTUP(ft1);
  1929.  
  1930.         found = set_with(found, (char *) e);
  1931. continue_forall_e:
  1932.         ;
  1933.     ENDFORSET(fs1);
  1934.  
  1935.  
  1936.     if (set_size(found) != 1 ) {
  1937. #ifdef ERRNUM
  1938.         errmsgn(446, 433, current_node);
  1939. #else
  1940.         errmsg("ambiguous or invalid entry name in renaming", "8.5", current_node);
  1941. #endif
  1942.         N_AST1(entry_expr) = OPT_NODE;
  1943.         N_AST2(entry_expr) = OPT_NODE;
  1944.         N_AST3(entry_expr) = OPT_NODE;
  1945.         nk = N_KIND(entry_expr);
  1946.         if (N_AST4_DEFINED(nk)) N_AST4(entry_expr) = (Node)0;
  1947.     }
  1948.     else {
  1949.         /* use entry name to complete resolution of task name*/
  1950.         e_name = (Symbol) set_arb(found);
  1951.         N_UNQ(entry_node) = e_name;
  1952.         complete_task_name(task_node, TYPE_OF(SCOPE_OF(e_name)));
  1953.         check_modes(formals, e_name);
  1954.     }
  1955. }
  1956.  
  1957. Tuple check_nat_type(Node expr_node)     /*;check_nat_type*/
  1958. {
  1959.     /* Obtain the nature and the actual type of of a renamed  expression,
  1960.      * and verify that it designates an object.
  1961.      */
  1962.  
  1963.     Symbol    expn;
  1964.     int        nat, nk;
  1965.     Symbol    t, s;
  1966.     Node    exp1, exp2;
  1967.     int        nrec, nfield;
  1968.     Tuple    tup;
  1969.  
  1970.     if (N_KIND(expr_node) == as_simple_name) {
  1971.         expn = N_UNQ(expr_node);
  1972.         nat = NATURE(expn);
  1973.         t = TYPE_OF(expn);
  1974.         if (nat !=na_constant
  1975.           && nat!= na_in
  1976.           && nat!= na_inout
  1977.           && nat!= na_out
  1978.           && nat!= na_obj) {
  1979. #ifdef ERRNUM
  1980.             errmsgn(449, 433, expr_node);
  1981. #else
  1982.             errmsg("Renamed entity must be an object", "8.5", expr_node);
  1983. #endif
  1984.         }
  1985.         tup = tup_new(2);
  1986.         tup[1] = (char *) nat;
  1987.         tup[2] = (char *) t;
  1988.         return tup;
  1989.     }
  1990.     else {
  1991.         /* Predefined operation, or call.*/
  1992.         exp1 = N_AST1(expr_node);
  1993.         exp2 = N_AST2(expr_node);
  1994.  
  1995.         nk = N_KIND(expr_node);
  1996.  
  1997.         if (nk == as_index) {
  1998.             /* The nature of an indexed component is the same as the
  1999.              * nature of the array object itself.
  2000.              */
  2001.             tup = check_nat_type(exp1);
  2002.             t = (Symbol) tup[2];
  2003.             tup[2] = (char *) component_type(t);
  2004.             return tup;
  2005.         }
  2006.         else if (nk == as_slice) {
  2007.             /* The nature of the slice is that of the array object.*/
  2008.             return check_nat_type(exp1);
  2009.         }
  2010.         else if (nk == as_selector) {
  2011.             tup = check_nat_type(exp1);
  2012.             nrec = (int) tup[1];
  2013.             s = N_UNQ(exp2);
  2014.             nfield = NATURE(s);
  2015.             t = TYPE_OF(s); /* attrs. of selector */
  2016.             /* IF selector is a discriminant, the new entity must be
  2017.              * treated as such.  Otherwise the  nature of the record
  2018.              * object (constant, formal, etc.) determines that of the
  2019.              * new entity.
  2020.              */
  2021.             nat = (nfield == na_discriminant) ? na_constant : nrec;
  2022.             tup = tup_new(2);
  2023.             tup[1] = (char *) nat;
  2024.             tup[2] = (char *) t;
  2025.             return tup;
  2026.         }
  2027.         else if (nk == as_all) {
  2028.             /* A dereferenced pointer always yields an object.*/
  2029.             tup = check_nat_type(exp1);
  2030.             nat = (int) tup[1];
  2031.             t = (Symbol)tup[2];
  2032.             /*tup_free(tup); may be possible here */
  2033.             tup = tup_new(2);
  2034.             tup[1] = (char *)na_obj;
  2035.             tup[2] =(char *) designated_type(t);
  2036.             return tup;
  2037.         }
  2038.         else if (nk == as_call) {
  2039.             /* The function being called must yield an access type.*/
  2040.             t = N_TYPE(expr_node);
  2041.             if (!is_access(t)) {
  2042. #ifdef ERRNUM
  2043.                 errmsgn(449, 433, expr_node);
  2044. #else
  2045.                 errmsg("Renamed entity must be an object", "8.5", expr_node);
  2046. #endif
  2047.             }
  2048.             tup = tup_new(2);
  2049.             tup[1] = (char *) na_obj;
  2050.             tup[2] = (char *) t;
  2051.             return tup;
  2052.         }
  2053.         else if (nk == as_ivalue) {
  2054.             tup = tup_new(2);
  2055.             tup[1] = (char *) na_constant;
  2056.             tup[2] = (char *) symbol_any;
  2057.             return tup;
  2058.         }
  2059.         else {
  2060.             /*error somewhere.*/
  2061.             tup = tup_new(2);
  2062.             tup[1] = (char *) na_obj;
  2063.             tup[2] = (char *) symbol_any;
  2064.             return tup;
  2065.         }
  2066.     }
  2067. }
  2068.  
  2069. void newscope(Symbol new_name)  /*;newscope*/
  2070. {
  2071.     Tuple    tup;
  2072.     int    old_size;
  2073.     int    i;
  2074.  
  2075.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  newscope");
  2076.     /*
  2077.      * This procedure is invoked when a new lexical scope is entered.
  2078.      * Lexical scopes include package specifications, package bodies ,
  2079.      * subprogram bodies and entry bodies (ACCEPT statements) . In addition
  2080.      * record and task declarations and private parts are treated as scopes.
  2081.      * In each case, the environment of the previous scope is stacked
  2082.      * and the symbol table for the new scope is initialized.
  2083.      */
  2084.     if (cdebug2 > 0)
  2085.         if (ORIG_NAME(new_name) != (char *) 0)
  2086.             printf("new scope %s\n", ORIG_NAME(new_name));
  2087.  
  2088.     tup = tup_new(4);
  2089.     tup[1] = (char *) scope_name;
  2090.     tup[2] = (char *) tup_copy(open_scopes);
  2091.     tup[3] = (char *) tup_copy(used_mods);
  2092.     tup[4] = (char *) tup_copy(vis_mods);
  2093.     scope_st = tup_with(scope_st, (char *) tup);
  2094.     scope_name = new_name;
  2095.  
  2096.     if (DECLARED(scope_name) == (Declaredmap)0) 
  2097.         DECLARED(scope_name) = dcl_new(0);
  2098.  
  2099.     /* save scope_name if new scope      ds 1 aug */
  2100.  
  2101.     /*open_scopes := [scope_name] + open_scopes;*/
  2102.     old_size = tup_size(open_scopes);
  2103.     open_scopes = tup_exp(open_scopes, (unsigned) old_size+1);
  2104.     for (i = old_size; i >= 1; i--)
  2105.         open_scopes[i+1] = (char *) open_scopes[i];
  2106.     open_scopes[1] = (char *) scope_name;
  2107. #ifdef TBSN
  2108. suffix :
  2109.     = str newat;
  2110.     $ For the formation of unique names
  2111. #endif
  2112. }
  2113.  
  2114. void popscope()   /*;popscope*/
  2115. {
  2116.     Tuple    tup;
  2117.  
  2118.     if (cdebug2 > 3)
  2119.         TO_ERRFILE("AT PROC :  popscope");
  2120.     /*
  2121.      * Ths procedure is called on exit from a completed lexical scope.
  2122.      * Eventually , it should contain various housekeeping functions
  2123.      * relating to symbol table statistics and space recovery. For now
  2124.      * it simply restores the environment of the enclosing scope.
  2125.      *
  2126.      * As each scope is closed, a symbol table dump may be done, controled
  2127.      * by the value of cdebug2:
  2128.      *
  2129.      *     cdebug2 = 2  :  show entries for current scope without signature
  2130.      *     cdebug2 > 2  :  show entries for current scope with signature
  2131.      *     cdebug2 > 6  :  show entries for all user defined scopes
  2132.      *     cdebug2 = 9  :  show entries for all declared scopes
  2133.      */
  2134.     if (cdebug2 > 1) {
  2135. #ifdef TBSLN
  2136.         loop forall scop in
  2137.             if cdebug2 = 9 then domain declared
  2138.         elseif cdebug2 > 6 then domain(declared) -
  2139.             ({
  2140.             'STANDARD#0', 'UNMENTIONABLE#0', 'ASCII'        }
  2141.         +
  2142.             {
  2143.             x(2) :
  2144.             x in PREDEF_UNITS        }
  2145.         )
  2146. else {
  2147.     scope_name}
  2148. end
  2149. do
  2150. sig_flag :
  2151.     = (cdebug2 > 2) and
  2152.         exists [item, u_name] in DECLARED(scop) |
  2153.         SIGNATURE(u_name) /= om;
  2154. errstr "--- Symbol table entries for declared("+scop+"):";
  2155. TO_ERRFILE(errstr );
  2156. errstr = rpad("Id", 15) + rpad("Unique name", 25) +
  2157. rpad("Nature", 15) + rpad("Type", 24) +
  2158. if sig_flag then " Signature" else "" end;
  2159. TO_ERRFILE(errstr );
  2160. (forall [item, u_name] in DECLARED(scop))
  2161. line :
  2162. = rpad(item ? "", 14);
  2163. line := rpad(line + " " + u_name ? "", 39);
  2164. line := rpad(line + " " + nature(u_name) ? "", 54);
  2165. line := rpad(line + " " +
  2166. if is_string(type_of(u_name)) then type_of(u_name)
  2167. else str type_of(u_name) end, 79);
  2168. if sig_flag and signature(u_name) /= om then
  2169. line +:
  2170. = " " + str signature(u_name);
  2171. end if;
  2172. TO_ERRFILE(line);
  2173. line :
  2174. =  str (overloads(u_name)) + " "
  2175. + str scope_of(u_name)    + " "
  2176. + str alias(u_name);
  2177. TO_ERRFILE(line);
  2178.  
  2179. end forall;
  2180. end loop;
  2181. #endif
  2182.     }
  2183.     tup = (Tuple) tup_frome(scope_st);
  2184.     scope_name = (Symbol) tup[1];
  2185.     open_scopes = (Tuple) tup[2];
  2186.     used_mods = (Tuple) tup[3];
  2187.     vis_mods = (Tuple) tup[4];
  2188.     if (cdebug2 > 0) TO_ERRFILE("return to scope: " );
  2189. }
  2190.  
  2191. void newmod(char *name)   /*;newmod*/
  2192. {
  2193.     Symbol    new_name;
  2194.  
  2195.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  newmod");
  2196.  
  2197.     /* Update this comment*/
  2198.  
  2199. #ifdef SKIPTHIS
  2200.     -- I think all we need is find_new call
  2201.         if (IS_COMP_UNIT){
  2202.         /* TBSN- SETL has new_name := name. But in C, name is string, and
  2203.    new_name is symbol table pointer. Try replacing with find_new
  2204.     new_name = name;
  2205.  */
  2206.         new_name = find_new(name);
  2207.         /* Enter module name in STANDARD*/
  2208.         if (dcl_get(DECLARED(scope_name), name) == (Symbol)0) {
  2209.             dcl_put(DECLARED(scope_name), name, new_name);
  2210.             SCOPE_OF(new_name) = scope_name;
  2211.             TO_XREF(new_name);
  2212.         }
  2213.         else {
  2214. #ifdef ERRNUM
  2215.             str_errmsgn(450, name, 143, current_node);
  2216. #else
  2217.             errmsg_str("Duplicate declaration of %", name , "8.3", current_node);
  2218. #endif
  2219.         }
  2220.     }
  2221.     else {
  2222.         new_name = find_new(name);
  2223.     }
  2224. #endif
  2225.     new_name = find_new(name);
  2226.     ORIG_NAME(new_name) = strjoin(name, "");
  2227.     /* Initialize its symbol table and enter scope.  */
  2228.     DECLARED(new_name) = dcl_new(0);
  2229.     /*declared(new_name) := visible(new_name) := {};*/
  2230.     newscope(new_name);
  2231.     /* and update prefix of names with current module name. */
  2232. #ifdef TBSN
  2233.     prefix = prefix + name + '.';
  2234. #endif
  2235. }
  2236.  
  2237. void use_clause(Node node)                    /*;use_clause*/
  2238. {
  2239.     /* If the use clause appears within a package specification, it constitutes
  2240.      * a declarative item that is visible in the corresponding body, and must
  2241.      * be saved in the declared map of the package.
  2242.      */
  2243.  
  2244.     Node    id_node;
  2245.     char    *id;
  2246.     Symbol    rnam, uds, un;
  2247.     Fortup    ft1;
  2248.     Fordeclared fd;
  2249.     int     nat;
  2250.  
  2251.     nat = NATURE(scope_name);
  2252.     if (nat == na_package_spec || nat == na_generic_package_spec
  2253.       || nat == na_private_part)
  2254.         /*use_declarations(scope_name) +:= used;*/
  2255.         uds = dcl_get(DECLARED(scope_name), "$used");
  2256.     else uds = (Symbol)0;
  2257.  
  2258.     FORTUP(id_node =(Node), N_LIST(node), ft1);
  2259.         id = N_VAL(id_node);
  2260.         check_old(id_node);
  2261.         rnam = N_UNQ(id_node);
  2262.         if (rnam == symbol_undef) {
  2263. #ifdef ERRNUM
  2264.             str_errmsgn(451, id, 452, id_node);
  2265. #else
  2266.             errmsg_str("undeclared package name %", id, "8.4, 10.1", id_node);
  2267. #endif
  2268.         }
  2269.         else if (N_OVERLOADED(id_node) ||
  2270.           NATURE(rnam)!=na_package && NATURE(rnam) !=na_package_spec){
  2271. #ifdef ERRNUM
  2272.             str_errmsgn(453, id, 454, id_node);
  2273. #else
  2274.             errmsg_str("% is not the name of a USEable package", id,
  2275.               "8.4", id_node);
  2276. #endif
  2277.         }
  2278.         else {
  2279.             if (!tup_mem((char *) rnam, used_mods))
  2280.                 used_mods = tup_with(used_mods, (char *) rnam);
  2281.             /* inner packages defined in a 'used' package can now be used to
  2282.                * qualify their inner entities
  2283.                */
  2284.             if (DECLARED(rnam) != (Declaredmap)0) { /* in case of error */
  2285.                 FORDECLARED(id, un, DECLARED(rnam), fd);
  2286.                     if (IS_VISIBLE(fd) && (NATURE(un) == na_package
  2287.                       || NATURE(un) == na_package_spec))
  2288.                         vis_mods = tup_with(vis_mods, (char *) un);
  2289.                 ENDFORDECLARED(fd);
  2290.             }
  2291.             if (uds != (Symbol)0)
  2292.                 SIGNATURE(uds) = tup_with(SIGNATURE(uds), (char *)rnam);
  2293.         }
  2294.     ENDFORTUP(ft1);
  2295. }
  2296.